;; Implements functionality required by machine.scm
;;
;; TODO: 
;;  output ports, should they be singleton objects? or classes?
;; refactor globals system, should only be ONE globals namespace
;;

(module woof-kernel mzscheme
  (require (lib "list.ss" "srfi" "1"))
  (require (only (lib "list.ss" "mzlib")
		 quicksort mergesort))
  (require (lib "34.ss" "srfi")) ;provides exception handling
  (require (all-except (lib "43.ss" "srfi")
                       vector->list
                       vector-fill!))
  (require (lib "defmacro.ss"))
  (require (lib "kw.ss"))
  (require (planet "test.ss" ("schematics" "schemeunit.plt" 2 1)))
  (require (planet "text-ui.ss" ("schematics" "schemeunit.plt" 2)))
  (require (planet "read.ss" ("ryanc" "scripting.plt" 1))) ;provides read-all
  
  (defmacro if-bind (name cond then else)
    `(let ((,name ,cond))
       (if ,name
           ,then
           ,else)))
  
  (define hash-key-count
    (lambda (hash)
      (length (hash-table-map hash (lambda (key val) val)))))
  
  
  
  
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;; define data structures and their constructors ;;
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  
  
  (define-struct woof-object (class fields prim-data))
  (define new-woof-object
    (lambda/kw (#:key [class #f] [fields (make-hash-table 'equal)] [prim-data #f])
               (make-woof-object
                class
                fields
                prim-data)))
  
  (define-struct (woof-function-object woof-object) (sig specs lambda block))
  (define new-woof-function-object
    (lambda/kw (#:key [class #f] [fields (make-hash-table 'equal)] [prim-data #f] [sig ""]
                      [specs '()] [lambda (lambda() #f)] [block #f] )
               (make-woof-function-object
                class
                fields
                prim-data
                sig
                specs
                lambda
                block
                )))
  
  (define-struct (woof-class-object woof-object) (name super slots super-list))
  (define new-woof-class-object
    (lambda/kw (#:key [class #f] [fields (make-hash-table 'equal)] [prim-data #f] [name ""]
                      [super #f] [slots '()] [super-list '()] )
               (make-woof-class-object
                class
                fields
                prim-data
                name
                super
                slots
		super-list
		)))
  
  
  (define-struct (woof-block-object woof-object) (code code-pc home))
  (define new-woof-block-object
    (lambda/kw (globals #:key [class (class-by-name "Block" globals)]
			[fields (make-hash-table 'equal)] [prim-data #f] [code '()]
			[code-pc 0] [home (new-block-context #:env ())])
               (make-woof-block-object
                class
                fields
                prim-data
                code
                code-pc
		home
                )))
  
  (define new-top-level-block
    (lambda (state code)
      (new-woof-block-object
       (machine-state-globals state)
       #:code code
       #:home (woof-nil (machine-state-globals state))
       #:code-pc 0
       )))
  
  
  (define-struct block-context (pc block stack sender home tmps env))
  (define new-block-context
    (lambda/kw (#:key [pc 0] [block] [stack ()] [sender] [home] [tmps ()] [env ()])
               (make-block-context
		pc
                block
		stack
		sender
		home
		tmps
		env 
		)))
  
  
  (define-struct (woof-continuation woof-object) (context))
  (define new-woof-continuation
    (lambda/kw (globals #:key [class (class-by-name "Continuation" globals)]
			[fields (make-hash-table 'equal)] [prim-data #f]
			[context])
               (make-woof-continuation
		class
		fields
		prim-data
		context
		)))
  
  (define-struct woof-globals (functions classes misc))
  (define new-woof-globals
    (lambda/kw (#:key [functions (make-hash-table 'equal)]
                      [classes (make-hash-table 'equal)]
		      [misc (make-hash-table 'equal)] )
               (make-woof-globals
                functions
                classes
		misc
                )))
  
  (define-struct return-addr (pc fn-code env))
  (define new-return-addr
    (lambda/kw (#:key [pc 0] [fn-code ()] [env ()])
	       (make-return-addr
		pc
		fn-code
		env)))
  
  (define-struct machine-state (active-context globals))
  (define new-machine-state
    (lambda/kw (#:key [active-context] [globals (new-woof-globals)])
	       (make-machine-state
		active-context
		globals
		)))
  
  (define machine-state-env
    (lambda (state)
      (block-context-env (machine-state-active-context state))))
  
  (define print-env
    (lambda (env)
      (map (lambda (ea) (begin (printf "(")
			       (vector-for-each
				(lambda (i var)
				  (if (woof-object? var)
				      (print-woof-object var)))
				(block-context-tmps ea))
			       (printf ")")))
	   env)))
  
  (define copy-block-context-for-continuation
    (lambda (context)
      (let* ((sender (block-context-sender context))
	     (home (block-context-home context)))
	(make-block-context
	 (block-context-pc context)
	 (block-context-block context)
	 (list-copy (block-context-stack context))
	 (if (block-context? sender)
	     (copy-block-context-for-continuation sender)
	     sender)
	 (if (block-context? home)
	     (copy-block-context-for-continuation home)
	     home)
	 (block-context-tmps context)
	 (list-copy (block-context-env context))
	 ))))
  
  (define machine-state-stack
    (lambda (state)
      (block-context-stack (machine-state-active-context state))))
  
  (define machine-state-pc
    (lambda (state)
      (block-context-pc (machine-state-active-context state))))
  
  (define set-machine-state-pc!
    (lambda (state pc)
      (let ((context (machine-state-active-context state)))
	(set-block-context-pc! context pc))))
  
  (define machine-state-code
    (lambda (state)
      (woof-block-object-code
       (block-context-block
	(machine-state-active-context state)))))
  
  (define print-woof-object
    (lambda (o)
      (printf "<a ")
      (printf (woof-class-object-name (woof-object-class o)))
      (if (woof-object-prim-data o) (begin
				      (printf " - ")
				      (print (woof-object-prim-data o))))
      (printf ">")))
  
  ;; returns woof-nil if field not found
  (define read-woof-object-field
    (lambda (object field-name globals)
      (let ((field-hash (woof-object-fields object)))
	(hash-table-get
	 field-hash
	 field-name
	 (lambda () (woof-nil globals))))))
  
  ;; returns the value that was set
  (define set-woof-object-field!
    (lambda (object field-name value globals)
      (let ((field-hash (woof-object-fields object)))
	(hash-table-put! field-hash field-name value)
	value)))
  
  (define install-global!
    (lambda (obj name globals)
      (hash-table-put! (woof-globals-misc globals)
		       name
		       obj)))
  
  (define install-class!
    (lambda (class globals)
      (install-global! class (woof-class-object-name class) globals)))
  
  (define install-function!
    (lambda (w-func globals)
      (let* ((sig (woof-function-object-sig w-func))
	     (new-group (append (list w-func)
				(hash-table-get
				 (woof-globals-functions globals)
				 sig
				 (lambda () (list))))))
	(hash-table-put! (woof-globals-functions globals) sig new-group))))
  
  (define class-by-name
    (lambda (name globals)
      (global-by-name name globals)))
  
  (define global-by-name
    (lambda (name globals)
      (hash-table-get (woof-globals-misc globals) name (lambda () #f))))
  
  (define functions-by-sig
    (lambda (sig globals)
      (hash-table-get (woof-globals-functions globals) sig (lambda () '()))))
  
  (define create-meta-class-for
    (lambda (class globals)
      (let* ((super (woof-object-class (woof-class-object-super class)))
	     (new-class (new-woof-class-object
			 #:name (string-append "Meta" (woof-class-object-name class))
			 #:super super
			 #:super-list (append (list super)
					      (woof-class-object-super-list super))
			 #:class (class-by-name "MetaClass" globals)
			 )))
	(install-class! new-class globals)
	new-class)))
  
  (define create-class
    (lambda (name super globals)
      (let ((new-class (new-woof-class-object #:name name
					      #:super super
					      #:super-list (append (list super)
								   (woof-class-object-super-list super))
					      )))
	(set-woof-object-class! new-class (create-meta-class-for new-class globals))
	new-class)))
  
  ;; singleton instance of nil
  (define woof-nil
    (lambda (globals)
      (global-by-name "nil" globals)))
  
  ;; singleton instance of true
  (define woof-true
    (lambda (globals)
      (global-by-name "true" globals)))
  
  ;; singleton instance of false
  (define woof-false
    (lambda (globals)
      (global-by-name "false" globals)))
  
  (define woof-boolean-instance
    (lambda (s-bool globals)
      (if s-bool
	  (woof-true globals)
	  (woof-false globals)
	  )))
  
  (define woof-instance
    (lambda (w-class)
      (new-woof-object #:class w-class)))
  
  (define woof-string-instance
    (lambda (text globals)
      (let ((w-string (woof-instance (class-by-name "String" globals))))
	(set-woof-object-prim-data! w-string text)
	w-string)))
  
  (define woof-integer-instance
    (lambda (i globals)
      (let ((w-i (woof-instance (class-by-name "Integer" globals))))
	(set-woof-object-prim-data! w-i i)
	w-i)))
  
  (define woof-list-instance
    (lambda (s-list globals)
      (let ((w-list (woof-instance (class-by-name "List" globals))))
	(set-woof-object-prim-data! w-list s-list)
	w-list)))
  
  (define woof-block-instance
    (lambda (s-lambda globals)
      (let ((w-block (woof-instance (class-by-name "Block" globals))))
	(set-woof-object-prim-data! w-block s-lambda)
	w-block)))
  
  (define woof-function-instance
    (lambda (s-sig s-specs s-lambda)
      (let ((w-func (new-woof-function-object
		     #:sig s-sig
		     #:specs s-specs
		     #:lambda s-lambda)))
	w-func)))
  
  (define init-proto-globals!
    (lambda (globals)
      (let ((nil (new-woof-class-object
		  #:name "nil"
		  ))
	    (metaclass (new-woof-class-object
			#:name "MetaClass"
			))
	    )
	(set-woof-class-object-super! nil nil)
	(set-woof-object-class! nil nil)
	(install-class! nil globals)
	(install-global! nil "nil" globals)
	(set-woof-class-object-super! metaclass nil)
	(set-woof-object-class! metaclass metaclass)
	(install-class! metaclass globals)
	globals)))
  
  (define init-woof-globals!
    (lambda (globals)
      (init-proto-globals! globals)
      (let ((nil (class-by-name "nil" globals))
	    (metaclass (class-by-name "MetaClass" globals)))
	(install-class! (create-class "Class" nil globals) globals)
	(install-class! (create-class "Object" nil globals) globals)
	;;Set MetaObject's super to Class
	(set-woof-class-object-super!
	 (woof-object-class (class-by-name "Object" globals))
	 (class-by-name "Class" globals))
	(install-class! (create-class "String" (class-by-name "Object" globals) globals)
			globals)
	(install-class! (create-class "Integer" (class-by-name "Object" globals) globals)
			globals)
	(install-class! (create-class "List" (class-by-name "Object" globals) globals)
			globals)
	(install-class! (create-class "Function" (class-by-name "Object" globals) globals)
			globals)
	(install-class! (create-class "Block" (class-by-name "Object" globals) globals)
			globals)
	(install-class! (create-class "Continuation" (class-by-name "Object" globals) globals)
			globals)
	(install-class! (create-class "Exception" (class-by-name "Object" globals) globals)
			globals)
	(install-class! (create-class "Boolean" (class-by-name "Object" globals) globals)
			globals)
	(install-class! (create-class "True" (class-by-name "Boolean" globals) globals)
			globals)
	(install-class! (create-class "False" (class-by-name "Boolean" globals) globals)
			globals)
	
	(install-global! (woof-instance (class-by-name "False" globals)) "false" globals)
	(install-global! (woof-instance (class-by-name "True" globals)) "true" globals)
	
	(install-class! (create-class "Maybe" (class-by-name "Object" globals) globals)
			globals)
	
	(install-class! (create-class "Just" (class-by-name "Maybe" globals) globals)
			globals)
	
	(install-class! (create-class "Nothing" (class-by-name "Maybe" globals) globals)
			globals)        
	
	(install-class! (create-class "Port" (class-by-name "Object" globals) globals)
			globals)
	(install-class! (create-class "OutputPort" (class-by-name "Port" globals) globals)
			globals)
	(let ((stdout (woof-instance (class-by-name "OutputPort" globals))))
	  (set-woof-object-prim-data! stdout (current-output-port))
	  (install-global! stdout "STDOUT" globals))
	
	(install-function! (new-woof-function-object
			    #:sig "define:over:as:"
			    #:specs (list (class-by-name "String" globals)
					  (class-by-name "List" globals)
					  (class-by-name "Block" globals))
			    #:block (new-woof-block-object
				     globals
				     #:code '((ARGS 3)
					      (LVAR 0 0)
					      (LVAR 0 1)
					      (LVAR 0 2)
					      (CRFN)
					      (GETC "nil")
					      (RETURN)
					      )
				     #:code-pc 0)
			    ) globals)
	
	
	globals
	)))
  
  (define woof-call-function
    (lambda (s-sig s-args globals)
      (apply (woof-function-object-lambda (function-for s-sig s-args globals))
	     s-args)))
  
  (define function-for
    (lambda (s-sig s-args globals)
      (first (applicable-functions s-sig s-args globals))))
  
  (define applicable-functions
    (lambda (s-sig s-args globals)
      (let ((arg-classes
	     (map (lambda (ea) (woof-object-class ea))
		  s-args)))
	(sort-functions-by-specificity
	 (filter (lambda (f)
		   (every (lambda (pair) (class-conforms? (first pair) (second pair ) globals))
			  (zip arg-classes (woof-function-object-specs f))))
		 (functions-by-sig s-sig globals))))))
  
  ;; Check if c1 is a subtype of c2 or equal to c2
  (define class-conforms?
    (lambda (c1 c2 globals)
      (or (eq? c1 c2)
	  (let ((c1-super (woof-class-object-super c1)))
	    (if (not (eq? c1 (class-by-name "nil" globals)))
		(class-conforms? c1-super c2 globals)
		#f)))))
  
  (define class-more-specific?
    (lambda (c1 c2)
      (> (length (woof-class-object-super-list c1))
	 (length (woof-class-object-super-list c2)))))
  
  ;; sorts the funcs from most specific to least specific
  (define sort-functions-by-specificity
    (lambda (funcs)
      (quicksort funcs (lambda (f1 f2)
			 (any (lambda (c1 c2)
				(class-more-specific? c1 c2))
			      (woof-function-object-specs f1)
			      (woof-function-object-specs f2))))))
  
  
  (define raises-exception?
    (lambda (proc)
      (call-with-current-continuation
       (lambda (k) (with-exception-handler
		    (lambda (x)
		      (k #t))
		    (lambda () (apply proc '()) #f))))))
  
  (define kernel-tests
    (test-suite
     "Tests for the woof kernel."
     
     (test-case
      "Test create structures."
      (let ((object (new-woof-object
		     #:class 1
		     #:fields '()
		     #:prim-data 2)))
	(check-equal? 1 (woof-object-class object))
	(check-equal? '() (woof-object-fields object))
	(check-equal? 2 (woof-object-prim-data object))))
     
     (test-case
      "test class-by-name"
      (let ((globals (init-proto-globals! (new-woof-globals))))
	(check-true (woof-class-object? (class-by-name "nil" globals)))))
     
     (test-case
      "test installation of STDOUT"
      (let ((globals (init-woof-globals! (new-woof-globals))))
	(check-true (woof-object? (global-by-name "STDOUT" globals)))))
     
     (test-case
      "test create class"
      (let* ((globals (init-proto-globals! (new-woof-globals)))
	     (my-class (create-class "MyClass" (class-by-name "nil" globals) globals)))
	(check-true (woof-class-object? my-class))))
     
     (test-case
      "Test install-function"
      (let* ((sig "print:")
	     (specs (list (new-woof-class-object)))
	     (s-lambda (lambda() #f))
	     (func (woof-function-instance sig specs s-lambda))
	     (globals (new-woof-globals))
	     )
	(install-function! func globals)
	(check-eq? func (first (functions-by-sig "print:" globals)))))
     
     (test-case
      "After init, check installation of classes & funcs"
      (let ((globals (new-woof-globals)))
	(init-woof-globals! globals)
	(check-not-false (class-by-name "nil" globals))
	(check-not-false (class-by-name "Object" globals))
	(check-not-false (class-by-name "String" globals))
	(check-not-false (class-by-name "List" globals))
	(check-not-false (class-by-name "Function" globals))
	(check-false (equal? '() (functions-by-sig "define:over:as:" globals)))))
     
     (test-case
      "Test create a String object"
      (let ((globals (new-woof-globals)))
	(init-woof-globals! globals)
	(let ((w-string (woof-string-instance "yo" globals)))
	  (check-equal? "yo" (woof-object-prim-data w-string)))))
     
     (test-case
      "Test create a List object"
      (let ((globals (new-woof-globals)))
	(init-woof-globals! globals)
	(let ((w-list (woof-list-instance '(1 2 3 4) globals)))
	  (check-equal? '(1 2 3 4) (woof-object-prim-data w-list)))))
     
     (test-case
      "Check properties of define:over:as:"
      (let ((globals (new-woof-globals)))
	(init-woof-globals! globals)
	(let ((func (first (functions-by-sig "define:over:as:" globals))))
	  (check-equal? (list (class-by-name "String" globals)
			      (class-by-name "List" globals)
			      (class-by-name "Block" globals))
			(woof-function-object-specs func))
	  )))
     
     ))
  
  (define run-kernel-tests
    (lambda ()
      (test/text-ui kernel-tests)))
  
  (provide (all-defined))
  
  
  )
